#!/usr/bin/perl
# Extract the examples from the source files into the form for
# insertion into the book text.

use strict;

my $xml = 0;
my $suffix;
my $usage = "use: extract [-t|-x] destdir file...\n";

if ($ARGV[0] eq "-x") {
	$xml = 1;
	$suffix = ".xml";
} elsif($ARGV[0] eq "-t") {
	$xml = 0;
	$suffix = ".txt";
} else {
	die $usage;
}
shift;

my $destdir = shift @ARGV;
die $usage unless (-d $destdir);
my $linetoolong = 0;
my $lenlimit = 56; # limit the length of lines in examples

my $fname;
my $line;

sub normalize # (exname, text_line)
{
	my $exname = shift;
	my $tl = shift;
	$tl =~ s/    /\t/g;
	if ($xml) {
		# in XML form set tabs to 2 chars to reduce width
		$tl =~ s/\t/  /g;
		$tl =~ s/ +$//;
		
		# check that the line is not too long
		if (length $tl > $lenlimit) {
			print STDERR "In example $exname line $line too long: ". length($tl) .", limit $lenlimit\n";
			$linetoolong = 1;
		}

		$tl =~ s/\&/\&amp;/g;
		$tl =~ s/</\&lt;/g;
		$tl =~ s/>/\&gt;/g;
		$tl =~ s/"/\&quot;/g;
	} else {
		# in text form set tabs to 4 chars
		$tl =~ s/\t/    /g;
		# remove the line-breaking points
		# $tl =~ s/"\/\*\*\/"//; # if in the middle of a string then join it
		# $tl =~ s/\/\*\*\///;
	}
	return $tl;
}

for $fname (@ARGV)
{
	open FILE, "<", $fname
		or die "Can not open file '$fname' for reading: $!\n";

	my $inside = 0;
	my $inget = 0;
	my $skip = 0;
	my $exname;
	my %text;
	my %locations;
	my %descriptions;
	my %labels;
	my @movelines;
	my $movelabel;
	$line = 0;
	while(<FILE>) {
		chomp;
		++$line;
		if ($inside) {
			if (/^\s*\/\/ END/) {
				$inside = 0;
				undef $exname;
			} elsif (/^\s*\/\/ DEBUG *(.*)/) {
				# printf STDERR "Found DEBUG in $fname at line $line '$1'\n"; # SBDBG
				my @sp = split / +/, lc $1;
				# printf STDERR "Split '$1': " . join("+", @sp) . "\n"; # SBDBG
				if ($sp[0] eq "{" || $sp[0] eq "from") {
					++$skip;
				} elsif ($sp[0] eq "}" || $sp[0] eq "to" || $sp[0] eq "endget") {
					--$skip;
					$skip = 0 if ($skip < 0);
				} elsif ($sp[0] eq "getfrom") {
					my $l = $sp[1];
					$l =~ s/[^a-zA-Z]/_/g;
					die "A getfrom label on $fname line $line must not be empty\n" if ($l eq "");
					die "A getfrom label on $fname line $line must be unique\n" if (exists $labels{$l});
					$labels{$l} = $exname;
					push @{$text{$exname}}, "// DEBUG getfrom $l"; # mark the line to replace
					printf STDERR "Found getfrom $l in $fname at line $line\n"; # SBDBG
					++$skip;
				} elsif ($sp[0] eq "move") {
					die "A nested move on $fname line $line is not allowed, prev label '$movelabel'\n" if ($inget);
					my $l = $sp[1];
					$l =~ s/[^a-zA-Z]/_/g;
					die "A move on $fname line $line to an unknown label '$l'\n" if (!exists $labels{$l});
					$inget = 1;
					$movelabel = $l;
					undef @movelines;
					printf STDERR "Found move $movelabel in $fname at line $line\n"; # SBDBG
				} elsif ($sp[0] eq "endmove") {
					printf STDERR "Found endmove $movelabel in $fname at line $line\n"; # SBDBG
					die "An endmove on $fname line $line without move\n" unless ($inget);
					my $ot = $text{$labels{$movelabel}}; # a reference
					my @nt;
					my $tl;
					my $l = $labels{$movelabel};
					foreach $tl (@$ot) {
						if ($tl =~ /^\s*\/\/ DEBUG *getfrom *$movelabel *$/) {
							push @nt, @movelines;
							printf STDERR "Moved to label $movelabel in example " . $labels{$movelabel} . "in $fname at line $line\n"; # SBDBG
							delete $labels{$movelabel}; # satisfied, forget it
						} else {
							push @nt, $tl;
						}
					}
					@{$text{$l}} = @nt; # replace the text
					$inget = 0;
					undef $movelabel;
					undef @movelines;
				} elsif ($sp[0] eq "descr") {
					s/^\s*\/\/ DEBUG\s+\S+\s+//;
					$descriptions{$exname} = $_;
				}
			} else {
				s/\/\*DEBUG\{\*\/.*?\/\*\}DEBUG\*\///g;
				if ($inget) {
					push @movelines, $_;
				} elsif(!$skip) {
					push @{$text{$exname}}, $_;
				}
			}
		} else {
			if (/^\s*\/\/ \[\[(ex....)\]\]/) {
				$inside = 1;
				$skip = 0;
				$inget = 0;
				$exname=$1;
				die "Duplicate example '$exname' found on $fname line $line\n" if (exists $text{$exname});
				$text{$exname} = [];
				$locations{$exname} = $line;
				printf STDERR "Found example $exname in $fname at line $line\n"; # SBDBG
			}
		}
	}
	die "File '$fname' ends while in the middle of example '$exname'\n" if ($inside);
	die "File '$fname' contains unresolved getfroms: " . join(" ", keys %labels) . "\n"
		if (scalar keys %labels != 0);

	close FILE;

	my $ex;
	foreach $ex (sort keys %text) {
		my $destf = $destdir . "/" . $ex . $suffix;
		die "The file '$destf' already exists, probably found in multiple sources\n"
			if (-f $destf);

		open RES, ">", $destf
			or die "Can not open file '$destf' for writing: $!\n";

		my $ot = $text{$ex}; # a reference
		my $tl;
		$line = 0;
		my $footnote;
		if ($xml) {
			$footnote = '<footnote><para>Marked in the examples package as [[<emphasis role="bold">' 
				. $ex . "</emphasis>]]</para></footnote>";
			if (exists $descriptions{$ex}) {
				# a formal example
				print RES '<example id="' . $ex . '">';
				if (scalar(@$ot) > 8) {
					# permit breaking the longer examples across pages
					print RES '<?dbfo keep-together="auto" ?>';
				} else {
					print RES '<?dbfo keep-together="always" ?>';
				}
				print RES "\n<title>" . $descriptions{$ex} . $footnote . "</title>";
				print RES "\n<programlisting>";
			} else {
				# an inlined code snippet
				print RES '<para><programlisting id="' . $ex . '"><?dbfo keep-together="always" ?>';
			}
		}
		foreach $tl (@$ot) {
			++$line;
			my $ft = &normalize($ex, $tl);
			if ($xml) {
				print RES "\n" if ($line > 1);
				print RES $ft;
			} else {
				print RES "$ft\n";
			}
		}
		if ($xml) {
			if (exists $descriptions{$ex}) {
				print RES "</programlisting></example>\n";
			} else {
				print RES "$footnote</programlisting></para>\n";
			}
		}
		close RES
			or die "Can not write to file '$destf': $!\n";
	}

	die "Detected lines in '$fname' that are too long, aborting\n" if ($linetoolong);
}
